home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 22 / CU Amiga Magazine's Super CD-ROM 22 (1998)(EMAP Images)(GB)[!][issue 1998-05].iso / PowerPC / Programming / PPCsiod / sources / string.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-09-25  |  9.8 KB  |  377 lines
  1. /* Scheme In One Define.
  2.  
  3. The garbage collector, the name and other parts of this program are
  4.  
  5.  *                     COPYRIGHT (c) 1989 BY                              *
  6.  *      PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  7.  
  8. Conversion  to  full scheme standard, characters, vectors, ports, complex &
  9. rational numbers, and other major enhancments by
  10.  
  11.  *      Scaglione Ermanno, v. Pirinoli 16 IMPERIA P.M. 18100 ITALY        * 
  12.  
  13. Permission  to use, copy, modify, distribute and sell this software and its
  14. documentation  for  any purpose and without fee is hereby granted, provided
  15. that  the  above  copyright  notice appear in all copies and that both that
  16. copyright   notice   and   this  permission  notice  appear  in  supporting
  17. documentation,  and that the name of Paradigm Associates Inc not be used in
  18. advertising or publicity pertaining to distribution of the software without
  19. specific, written prior permission.
  20.  
  21. PARADIGM  DISCLAIMS  ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
  22. ALL  IMPLIED  WARRANTIES  OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
  23. PARADIGM  BE  LIABLE  FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
  24. ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
  25. IN  AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
  26. OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  27.  
  28. */
  29.  
  30. #include <stdio.h>
  31. #include <string.h>
  32. #include <ctype.h>
  33. #include <setjmp.h>
  34. #include <signal.h>
  35. #include <math.h>
  36.  
  37. #include "siod.h"
  38.  
  39. LISP strcons(long length)
  40. {long flag;
  41.  LISP s;
  42.  char *p;
  43.  flag = no_interrupt(1);
  44.  if(length>4)
  45.    {p = must_malloc(length);
  46.     NEWCELL(s,tc_string);
  47.     SNAME(s) = p;}
  48.  else
  49.    {NEWCELL(s,tc_string);
  50.     SNAME(s) = SSMALL(s);}
  51.  no_interrupt(flag);
  52.  return(s);}
  53.  
  54. LISP string_append(LISP args)
  55. {long size;
  56.  LISP l,s;
  57.  char *data;
  58.  size = 0;
  59.  for(l=args;CONSP(l);l=cdr(l))
  60.    {s = car(l);
  61.     if (NSTRINGP(s) && NSYMBOLP(s))
  62.       err("string-append",s,ERR_GEN_ARG | ERR_NSTR);
  63.     size = size + strlen(SNAME(s));}
  64.  s = strcons(size+1);
  65.  data = SNAME(s);
  66.  data[0] = 0;
  67.  for(l=args;CONSP(l);l=cdr(l))
  68.    strcat(data,SNAME(car(l)));
  69.  return(s);}
  70.  
  71. LISP makestring(LISP dim,LISP init)
  72. {long size,i;
  73.  LISP s;
  74.  char *data,in;
  75.  if(NINTNUMP(dim))
  76.    err("make-string",dim,ERR_FIRST | ERR_NINT);
  77.  if(CHARP(init)) in = CHARV(init);
  78.  else if(NULLP(init)) in = ' ';
  79.  else err("make-string",init,ERR_SECOND | ERR_NCHA);
  80.  size = INTNM(dim);
  81.  s = strcons(size+1);  
  82.  data = SNAME(s);
  83.  data[size] = 0;
  84.  for(i=0;i<size;i++)
  85.    data[i] = in;
  86.  return(s);}
  87.  
  88. LISP stringp(LISP x)
  89. {if STRINGP(x) 
  90.    return(truth);
  91.  return(NIL);}
  92.  
  93. LISP charp(LISP x)
  94. {if CHARP(x) 
  95.    return(truth);
  96.  return(NIL);}
  97.  
  98. LISP chartoint(LISP x)
  99. {LISP z;
  100.  if NCHARP(x) err("char->integer",x,ERR_GEN_ARG | ERR_NCHA);
  101.  z = intcons((long)CHARV(x));
  102.  return(z);}
  103.  
  104. LISP charcons(long c)
  105. {long flag;
  106.  LISP z;
  107.  flag=no_interrupt(1);
  108.  if(NNULLP(chararray[c]))
  109.    return(chararray[c]);
  110.  NEWCELL(z,tc_char);
  111.  CHARV(z) = (char)c;
  112.  chararray[c]=z;
  113.  no_interrupt(flag);
  114.  return(z);}
  115.  
  116. LISP inttochar(LISP x)
  117. {long in;
  118.  if NINTNUMP(x) err("integer->char",x,ERR_GEN_ARG | ERR_NINT);
  119.  in = INTNM(x);
  120.  if((in<0)||(in>255)) err("integer->char",x,ERR_IND_RAN);
  121.  return(charcons(in));}
  122.  
  123. LISP chardowncase(LISP x)
  124. {int in;
  125.  if NCHARP(x) err("char-downcase",x,ERR_GEN_ARG | ERR_NCHA);
  126.  in = CHARV(x);
  127.  return(charcons(tolower(in)));}
  128.  
  129. LISP charupcase(LISP x)
  130. {int in;
  131.  if NCHARP(x) err("char-upcase",x,ERR_GEN_ARG | ERR_NCHA);
  132.  in = CHARV(x);
  133.  return(charcons(toupper(in)));}
  134.  
  135. LISP charcmp(LISP x,LISP y)
  136. {LISP z;
  137.  if NCHARP(x) err("char-cmp",x,ERR_FIRST | ERR_NCHA);
  138.  if NCHARP(y) err("char-cmp",y,ERR_SECOND | ERR_NCHA);
  139.  z = intcons((long)(CHARV(x)-CHARV(y)));
  140.  return(z);}
  141.  
  142. LISP string_lenght(LISP x)
  143. {LISP z;
  144.  if NSTRINGP(x) err("string-length",x,ERR_GEN_ARG | ERR_NSTR);
  145.  z = intcons((long)strlen(SNAME(x))); 
  146.  return(z);}
  147.  
  148. LISP string_to_symbol(LISP x)
  149. {if NSTRINGP(x) err("string->symbol",x,ERR_GEN_ARG | ERR_NSTR);
  150.  if(strlen(SNAME(x)) > TKBUFFERN) 
  151.     err("string->symbol buffer overflow",NIL,ERR_GEN);
  152.  return(rintern(SNAME(x)));}
  153.  
  154. LISP symbol_to_string(LISP x)
  155. {LISP z;
  156.  char *p;
  157.  if ((NSYMBOLP(x) && NTYPEP(x,tc_macro))) 
  158.      err("symbol->string",x,ERR_GEN_ARG | ERR_NSYM); 
  159.  p = PNAME(x);
  160.  z = strcons(strlen(p)+1);
  161.  strcpy(SNAME(z),p);
  162.  return(z);}
  163.  
  164. LISP string_to_un_symbol(LISP x)
  165. {LISP z;
  166.  char *p;
  167.  if (NSTRINGP(x)) 
  168.      err("string->uninterned-symbol",x,ERR_GEN_ARG | ERR_NSTR); 
  169.  p = PNAME(x);
  170.  z = strcons(strlen(p)+1);
  171.  strcpy(SNAME(z),p);
  172.  (*z).type=tc_symbol;
  173.  return(z);}
  174.  
  175. LISP string_to_number(LISP x,LISP y,LISP z)
  176. {LISP tmp;
  177.  char *p;
  178.  if NSTRINGP(x) err("string->number",x,ERR_FIRST | ERR_NSTR); 
  179.  if NSYMBOLP(y) err("string->number",y,ERR_SECOND | ERR_NSYM); 
  180.  if NSYMBOLP(z) err("string->number",z,ERR_THIRD | ERR_NSYM); 
  181.  if(EQ(z,cintern("b")))
  182.   tmp=intcons(strtol(SNAME(x),&p,2));
  183.  else if(EQ(z,cintern("d")))
  184.   tmp=flocons(strtod(SNAME(x),&p));
  185.  else if(EQ(z,cintern("o")))
  186.   tmp=intcons(strtol(SNAME(x),&p,8));
  187.  else if(EQ(z,cintern("x")))
  188.   tmp=intcons(strtol(SNAME(x),&p,16));
  189.  else
  190.    err("Unknown format to string->number",z,ERR_GEN);
  191.  if(*p)
  192.    err("String to string->number must contain a number",x,ERR_GEN);
  193.  return(tmp);}
  194.  
  195. LISP number_to_string(LISP x,LISP y)
  196. {LISP z;
  197.  int amp,prec;
  198.  if (NNUMBERP(x)) err("number->string",x,ERR_FIRST | ERR_NNUM);
  199.  if (NCONSP(y)) err("number->string",y,ERR_SECOND | ERR_NPAI);
  200.  if EQ(car(y),cintern("int"))
  201.    switch(TYPE(x))
  202.     {case tc_flonum:
  203.        sprintf(tkbuffer,"%.0f",FLONM(x));
  204.        break;
  205.      case tc_compnum:
  206.        sprintf(tkbuffer,"%.0f%+.0fi",COMPRE(x),COMPIM(x));
  207.        break;
  208.      case tc_ratnum:
  209.        sprintf(tkbuffer,"%.0f",(double)RATNUM(x)/(double)RATDEN(x));
  210.        break;
  211.      case tc_intnum:
  212.        sprintf(tkbuffer,"%d",INTNM(x));
  213.        break;}
  214.  if EQ(car(y),cintern("heur"))
  215.    switch(TYPE(x))
  216.     {case tc_flonum:
  217.        sprintf(tkbuffer,"%.16g",FLONM(x));
  218.        break;
  219.      case tc_compnum:
  220.        sprintf(tkbuffer,"%.6g%+.6gi",COMPRE(x),COMPIM(x));
  221.        break;
  222.      case tc_ratnum:
  223.        sprintf(tkbuffer,"%d/%d",RATNUM(x),RATDEN(x));
  224.        break;
  225.      case tc_intnum:
  226.        sprintf(tkbuffer,"%d",INTNM(x));
  227.        break;}
  228.  z = strcons(strlen(tkbuffer)+1);
  229.  strcpy(SNAME(z),tkbuffer);
  230.  return(z);}
  231.  
  232. LISP integer_to_string(LISP numer,LISP base)
  233. {long n,i,resto;
  234.  LISP z;
  235.  double num,ba;
  236.  char *p;
  237.  n=0;
  238.  p=tkbuffer;
  239.  numer = tofloat(numer);
  240.  base = tofloat(base);
  241.  if (NFLONUMP(numer)||(modf(FLONM(numer),&ba)!=0.)) 
  242.       err("integer->string",numer,ERR_FIRST | ERR_NINT);
  243.  if (NFLONUMP(base)||(modf(FLONM(base),&ba)!=0.)) 
  244.       err("integer->string",base,ERR_SECOND | ERR_NINT);
  245.  num=FLONM(numer);
  246.  ba=FLONM(base);
  247.  while(num>0.)
  248.   {resto=(long)fmod(num,ba);
  249.    n++;
  250.    if(resto<10)
  251.     *p++='0'+(char)resto;
  252.    else
  253.     *p++='A'+(char)resto-(char)10;
  254.    num/=ba;
  255.    modf(num,&num);}
  256.  *p--='\0';
  257.  z = strcons(strlen(tkbuffer)+1);
  258.  for(i=0;i<n;i++)
  259.    *(SNAME(z)+i)=*(p-i);
  260.  *(SNAME(z)+i)='\0';
  261.  return(z);}
  262.  
  263. LISP string_to_list(LISP x)
  264. {LISP y,*z;
  265.  char *p;
  266.  if NSTRINGP(x) err("string->list",x,ERR_GEN_ARG | ERR_NSTR);
  267.  y = NIL;
  268.  z = &y;
  269.  for(p=SNAME(x);*p;p++)
  270.   {*z = cons(charcons(*p),NIL);
  271.    z = &CDR(*z);}
  272.  return y;}
  273.  
  274. LISP list_to_string(LISP x)
  275. {LISP s,tmp;
  276.  int lenght=1;
  277.  char *p;
  278.  if NCONSP(x) err("list->string",x,ERR_GEN_ARG | ERR_NPAI);
  279.  for(tmp=x;NNULLP(tmp);tmp=cdr(tmp))
  280.   {if(NCHARP(car(tmp)))err("list->string",tmp,ERR_GEN_ARG | ERR_NCHA);
  281.    lenght++;}
  282.  s = strcons(lenght);
  283.  p = SNAME(s);
  284.  for(tmp=x;NNULLP(tmp);tmp=cdr(tmp))
  285.   {*p = CHARV(car(tmp));
  286.    p++;}
  287.  *p = '\0';
  288.  return s;}
  289.  
  290. LISP string_copy(LISP x)
  291. {LISP z;
  292.  if NSTRINGP(x) err("string-copy",x,ERR_GEN_ARG | ERR_NSTR);
  293.  z = strcons(strlen(SNAME(x))+1);
  294.  strcpy(SNAME(z),SNAME(x)); 
  295.  return(z);}
  296.  
  297. LISP string_fill(LISP x,LISP y)
  298. {char *p,c;
  299.  if NSTRINGP(x) err("string-fill!",x,ERR_GEN_ARG | ERR_NSTR);
  300.  if NCHARP(y) err("string-fill!",y,ERR_GEN_ARG | ERR_NSTR);
  301.  c = CHARV(y);
  302.  p = SNAME(x);
  303.  while(*p!='\0')
  304.   *p++=c;
  305.  return(x);}
  306.  
  307. LISP string_cmp(LISP x,LISP y)
  308. {LISP z;
  309.  if NSTRINGP(x) err("string-cmp",x,ERR_FIRST | ERR_NSTR);
  310.  if NSTRINGP(y) err("string-cmp",y,ERR_SECOND | ERR_NSTR);
  311.  z = intcons((long)strcmp(SNAME(x),SNAME(y))); 
  312.  return(z);}
  313.  
  314. LISP string_cmpCI(LISP x,LISP y)
  315. {LISP z;
  316.  if NSTRINGP(x) err("string-cmp-CI",x,ERR_FIRST | ERR_NSTR);
  317.  if NSTRINGP(y) err("string-cmp-CI",y,ERR_SECOND | ERR_NSTR);
  318.  z = intcons((long)strcmpCI(SNAME(x),SNAME(y))); 
  319.  return(z);}
  320.  
  321. int strcmpCI(char *s,char *t)
  322. {for(;tolower(*s) == tolower(*t);s++,t++)
  323.   if(*s=='\0')
  324.     return 0;
  325.  return tolower(*s)-tolower(*t);}
  326.  
  327. LISP string_ref(LISP x,LISP y)
  328. {LISP z;
  329.  char *px;
  330.  long py;
  331.  if NSTRINGP(x) err("string-ref",x,ERR_FIRST | ERR_NSTR);
  332.  if NINTNUMP(y) err("string-ref",y,ERR_SECOND | ERR_NSTR);
  333.  px = SNAME(x);
  334.  py = (long)INTNM(y);
  335.  if (py < 0) err("string-ref",y,ERR_IND_RAN);
  336.  if (py >= strlen(px)) err("string-ref",y,ERR_IND_RAN);
  337.  z = charcons(*(px+py)); 
  338.  return(z);}
  339.  
  340. LISP string_set(LISP x,LISP y,LISP z)
  341. {char *px;
  342.  long py;
  343.  if NSTRINGP(x) err("string-set!",x,ERR_FIRST | ERR_NSTR);
  344.  if NINTNUMP(y) err("string-set!",y,ERR_SECOND | ERR_NNUM);
  345.  if NCHARP(z) err("string-set!",z,ERR_THIRD | ERR_NCHA);
  346.  px = SNAME(x);
  347.  py = (long)INTNM(y);
  348.  if (py < 0) err("string-set!",y,ERR_IND_RAN);
  349.  if (py >= strlen(px)) err("string-set!",y,ERR_IND_RAN);
  350.  *(px+py) = CHARV(z); 
  351.  return(x);}
  352.  
  353. LISP substring(LISP x,LISP y,LISP z)
  354. {LISP k;
  355.  long l,start,end;
  356.  char *c;
  357.  if NSTRINGP(x) err("substring",x,ERR_FIRST | ERR_NSTR);
  358.  if NINTNUMP(y) err("substring",y,ERR_SECOND | ERR_NINT);
  359.  if NINTNUMP(z) err("substring",z,ERR_THIRD | ERR_NINT);
  360.  l = strlen(SNAME(x));
  361.  start = INTNM(y);
  362.  end = INTNM(z);
  363.  if (l < start) err("substring",y,ERR_IND_RAN);
  364.  if (l < end) err("substring",z,ERR_IND_RAN);
  365.  if (end < start) err("substring",z,ERR_IND_RAN);
  366.  k = strcons(end-start+1);
  367.  c=SNAME(k);
  368.  strncpy(c,SNAME(x)+start,end-start);
  369.  *(c+end-start)='\0';
  370.  return(k);}
  371.  
  372. LISP dos_call(LISP x)
  373. {
  374.  if NSTRINGP(x) err("dos-call",x,ERR_GEN_ARG | ERR_NSTR);
  375.  system(SNAME(x));
  376.  return (truth);}
  377.